perm filename RESTS.OLD[MSS,LCS]1 blob sn#170761 filedate 1975-07-26 generic text, type T, neo UTF8
00100		SUBROUTINE RESTS
00200		COMMON/STF/RSTFAC(-3/4),RSTJ2 /XXX/LK,LP,JY
00300		COMMON/XRN/RN(2000),XN(2000)
00400		COMMON RS,JA,CENTR,J2,RQ(18),JX,JR,LX,RDIS
00500		COMMON/POSI/STFF(-3/4),JJ2,PQ/PTR/PWDS(250),L,LL,I,IX
00600		EQUIVALENCE (RQ(2),XLFT),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
00700	C  RQ(2) IS R4, RQ(3) IS R5 ETC.
01000		REST=0
01100	CC	DO 231 K=LX,L-1
01150		K=LX
01200	5	JL=PWDS(K)
01300		R=RN(JL+1)
01400		IF(R.NE.8)GO TO 232
01500		XLFT=RN(JL+3)
01600		GO TO 231
01700	232	IF(R.NE.2)GO TO 231
01800		IF(RN(JL).LT.6)GO TO 231
01900	C FOUND A WHOLE REST MEAS.
02000		IF(REST.NE.0)GO TO 6
02050		JR=JL+8
02060	C  POINTER TO REST NUM.
02075		RN(JR-1)=RN(JR-1)*.6
02112	C  REDUCE SIZE OF REST'S TIME SO IT WILL TAKE LESS SPACE.
02150	6	REST=REST+1
02200		RN(JR)=REST
02300		LB=PWDS(K+2)
02400		IF(RN(LB+1).NE.2)GO TO 233
02500	C NEXT IS TO COMBINE MEASURES OF REST
02600		IF(RN(LB).LT.6)GO TO 233
02605	C  SKIP NON-WHOLE RESTS
02610		N=PWDS(K+1)
02620		IF(RN(N+1).NE.4)GO TO 233
02630	C  IS REST FOLLOWED BY A BAR?
02700	CCC	RN(LB+1)=0
02800	C SO IT WON'T BE FOUND NEXT TIME AROUND.
02900		RN(LB+3)=-99
03000	C  MOVE IT FAR LET
03100	CCC	LB=PWDS(K+1)
03200		RN(N+3)=-99
03300	C  MOVES PPEV. BAR ALSO
03350		K=K+2
03400		GO TO 5
03500	
03600	233	REST=0
03700	231	K=K+1
03750		IF(K.LT.L)GO TO 5
03800	
03900	C  NEXT DELETES UNWANTED ITEMS
04000		K=LX
04100	1	J=PWDS(K)
04110		RZ=RN(J+3)
04120		IF(RN(J+1).NE.5)GO TO 7
04130	C  IS IT A SLUR?
04140		IF(RN(J+6).GT.200)RN(J+6)=199.99
04150	C  .LT. XLFT IS OK FOR SLUR, BUT RT. SIDE MUST BE .LE. 200
04160		GO TO 2
04200	7	IF(RZ.GE.XLFT)GO TO 2
04300		N=PWDS(K+1)-J
04400		DO 3 M=J,IFIX(PWDS(L))
04500	3	RN(M)=RN(M+N)
04550		RZ=N
04600		DO 4 M=K+1,L-1
04700	4	PWDS(M)=PWDS(M+1)-RZ
04800		L=L-1
04850		JX=JX-1
04860		LK=LK-N
04870		LP=LK
04880		JY=LK
04890	C  SHOULD THESE EVER BE DIFFERENT?????
04950		GO TO 1
04955	
04960	2	IF(RZ.GT.200)RN(J+3)=200
04970	C  NOTHING CAN START PAST 200.
05000	 	K=K+1
05100		IF(K.LT.L)GO TO 1
05200		END
05300	
29000		FUNCTION R4567(R)
29100		R4567=0
29200		IF(R.LT.4)GO TO 1
29300		IF(R.LE.7)RETURN
29400	1	R4567=-1
29500		END
29600	
29700		SUBROUTINE BMQ(RN,NZ,A)
29800		DIMENSION RN(1)
30000		RR=RN(NZ)
30100		IF(RR.LT.7)RETURN
30200	C  FOR IRREGULAR BEAMS (THERE ARE AT LEAST 9 PARAMS.)
30300		IF(RR.NE.7)GO TO 129
30400	429	IF(RN(NZ+8).NE.0)GO TO 229
30500		RETURN
30600	129	IF(RN(NZ+10).EQ.0)GO TO 429
30700		IF(RN(NZ+10).LT.30)GO TO 229
30800		RB=RN(NZ+8)
30900		IF(RB.GT.A)RN(NZ+8)=BMX(RB,A)
31000	229	RB=RN(NZ+9)
31100		IF(RB.GT.A)RN(NZ+9)=BMX(RB,A)
31200		END
31300	
31400		FUNCTION BMX(RB,A)
31410		COMMON /PX/POS,SX
31500		BMX=RB+SX
31600		IF(A.EQ.-1000.)BMX=POSX(RB)
31700		END
31800	
32000		FUNCTION POSX(R)
32100		COMMON /PX/POS,SX
32200		POSX=POS+(R-POS)*SX
32300		END
32400	
32500		FUNCTION RCLEF(R)
32600		DIMENSION R(1)
32700		RCLEF=0
32800		IF(R(2).NE.3)RETURN
32900		IF(R(1).LT.3)RETURN
33000		IF(R(6).LE.3)RETURN
33100	C  FINDS ONLY 'REAL' CLEFS IN CODE NUM.3
33200		RCLEF=-1
33300		END